Aminet 1/Aminet - June 1993 [Walnut Creek].iso/usenet/sources/volume90/aplictns/xscheme2/part05

Internet Message Format | 1990-04-14 | 36.1 KB

Path: xanth!cs.odu.edu!Amiga-Request
From: [e-mail] (Amiga Sources/Binaries Moderator)
Newsgroups: comp.sources.amiga
Subject: v90i143: XScheme 0.20 - an object-oriented scheme, Part05/07
Message-ID: <[e-mail]>
Date: 14 Apr 90 21:12:44 GMT
Sender: [e-mail]
Reply-To: [e-mail] (Rusty Haddock)
Lines: 1499
Approved: [e-mail] (Tad Guy)
X-Mail-Submissions-To: [e-mail]
X-Post-Discussions-To: comp.sys.amiga

Submitted-by: [e-mail] (Rusty Haddock)
Posting-number: Volume 90, Issue 143
Archive-name: applications/xscheme-0.20/part05

#!/bin/sh
# This is a shell archive.  Remove anything before this line, then unpack
# it by saving it into a file and typing "sh file".  To overwrite existing
# files, type "sh file -c".  You can also feed this as standard input via
# unshar, or by typing "sh <file", e.g..  If this archive is complete, you
# will see the following message at the end:
#        "End of archive 5 (of 7)."
# Contents:  Src/xscom.c
# Wrapped by tadguy@xanth on Sat Apr 14 17:07:28 1990
PATH=/bin:/usr/bin:/usr/ucb ; export PATH
if test -f 'Src/xscom.c' -a "${1}" != "-c" ; then
  echo shar: Will not clobber existing file \"'Src/xscom.c'\"
else
echo shar: Extracting \"'Src/xscom.c'\" \(33402 characters\)
sed "s/^X//" >'Src/xscom.c' <<'END_OF_FILE'
X/* xscom.c - a simple scheme bytecode compiler */
X/*    Copyright (c) 1988, by David Michael Betz
X    All Rights Reserved
X    Permission is granted for unrestricted non-commercial use    */
X
X#include "xscheme.h"
X#include "xsbcode.h"
X
X/* size of code buffer */
X#define CMAX    4000
X
X/* continuation types */
X#define C_RETURN    -1
X#define C_NEXT        -2
X
X/* macro to check for a lambda list keyword */
X#define lambdakey(x)    ((x) == lk_optional || (x) == lk_rest)
X
X/* external variables */
Xextern LVAL lk_optional,lk_rest,true;
X
X/* local variables */
Xstatic LVAL info;        /* compiler info */
X
X/* code buffer */
Xstatic unsigned char cbuff[CMAX];    /* base of code buffer */
Xstatic int cbase;            /* base for current function */
Xstatic int cptr;            /* code buffer pointer */
X
X/* forward declarations */
Xint do_define(),do_set(),do_quote(),do_lambda(),do_delay();
Xint do_let(),do_letrec(),do_letstar(),do_cond(),do_and(),do_or();
Xint do_if(),do_begin(),do_while(),do_access();
XLVAL make_code_object();
X
X/* integrable function table */
Xtypedef struct { char *nt_name; int nt_code,nt_args; } NTDEF;
Xstatic NTDEF *nptr,ntab[] = {
X    "ATOM",            OP_ATOM,    1,
X    "EQ?",            OP_EQ,        2,
X    "NULL?",        OP_NULL,    1,
X    "NOT",            OP_NULL,    1,
X    "CONS",            OP_CONS,    2,
X    "CAR",            OP_CAR,        1,
X    "CDR",            OP_CDR,        1,
X    "SET-CAR!",        OP_SETCAR,    2,
X    "SET-CDR!",        OP_SETCDR,    2,
X    "+",            OP_ADD,        -2,
X    "-",            OP_SUB,        -2,
X    "*",            OP_MUL,        -2,
X    "QUOTIENT",        OP_QUO,        -2,
X    "<",            OP_LSS,        -2,
X    "=",            OP_EQL,        -2,
X    ">",            OP_GTR,        -2,
X    0
X};
X
X/* special form table */
Xtypedef struct { char *ft_name; int (*ft_fcn)(); } FTDEF;
Xstatic FTDEF ftab[] = {
X    "QUOTE",    do_quote,
X    "LAMBDA",    do_lambda,
X    "DELAY",    do_delay,
X    "LET",        do_let,
X    "LET*",        do_letstar,
X    "LETREC",    do_letrec,
X    "DEFINE",    do_define,
X    "SET!",        do_set,
X    "IF",        do_if,
X    "COND",        do_cond,
X    "BEGIN",    do_begin,
X    "SEQUENCE",    do_begin,
X    "AND",        do_and,
X    "OR",        do_or,
X    "WHILE",    do_while,
X    "ACCESS",    do_access,
X    0
X};
X
X/* xlcompile - compile an expression */
XLVAL xlcompile(expr,ctenv)
X  LVAL expr,ctenv;
X{
X    /* initialize the compile time environment */
X    info = cons(NIL,NIL); cpush(info);
X    rplaca(info,newframe(ctenv,1));
X    rplacd(info,cons(NIL,NIL));
X
X    /* setup the base of the code for this function */
X    cbase = cptr = 0;
X
X    /* setup the entry code */
X    putcbyte(OP_FRAME);
X    putcbyte(1);
X
X    /* compile the expression */
X    do_expr(expr,C_RETURN);
X
X    /* build the code object */
X    settop(make_code_object(NIL));
X    return (pop());
X}
X
X/* xlfunction - compile a function */
XLVAL xlfunction(fun,fargs,body,ctenv)
X  LVAL fun,fargs,body,ctenv;
X{
X    /* initialize the compile time environment */
X    info = cons(NIL,NIL); cpush(info);
X    rplaca(info,newframe(ctenv,1));
X    rplacd(info,cons(NIL,NIL));
X
X    /* setup the base of the code for this function */
X    cbase = cptr = 0;
X
X    /* compile the lambda list and the function body */
X    parse_lambda_list(fargs,body);
X    do_begin(body,C_RETURN);
X
X    /* build the code object */
X    settop(make_code_object(fun));
X    return (pop());
X}
X
X/* do_expr - compile an expression */
XLOCAL do_expr(expr,cont)
X  LVAL expr; int cont;
X{
X    LVAL fun;
X    if (consp(expr)) {
X    fun = car(expr);
X     if (!symbolp(fun) || (!in_ntab(expr,cont) && !in_ftab(expr,cont)))
X        do_call(expr,cont);
X    }
X    else if (symbolp(expr))
X    do_identifier(expr,cont);
X    else
X    do_literal(expr,cont);
X}
X
X/* in_ntab - check for a function in ntab */
XLOCAL int in_ntab(expr,cont)
X  LVAL expr; int cont;
X{
X    unsigned char *pname;
X    pname = getstring(getpname(car(expr)));
X    for (nptr = ntab; nptr->nt_name; ++nptr)
X    if (strcmp(pname,nptr->nt_name) == 0) {
X        do_nary(nptr->nt_code,nptr->nt_args,expr,cont);
X        return (TRUE);
X    }
X    return (FALSE);
X}
X
X/* in_ftab - check for a function in ftab */
XLOCAL int in_ftab(expr,cont)
X  LVAL expr; int cont;
X{
X    unsigned char *pname;
X    FTDEF *fptr;
X    pname = getstring(getpname(car(expr)));
X    for (fptr = ftab; fptr->ft_name; ++fptr)
X    if (strcmp(pname,fptr->ft_name) == 0) {
X        (*fptr->ft_fcn)(cdr(expr),cont);
X        return (TRUE);
X    }
X    return (FALSE);
X}
X
X/* do_define - handle the (DEFINE ... ) expression */
XLOCAL do_define(form,cont)
X  LVAL form; int cont;
X{
X    if (atom(form))
X    xlerror("expecting symbol or function template",form);
X    define1(car(form),cdr(form),cont);
X}
X
X/* define1 - helper routine for do_define */
XLOCAL define1(list,body,cont)
X  LVAL list,body; int cont;
X{
X    LVAL fargs;
X    int off;
X
X    /* handle nested definitions */
X    if (consp(list)) {
X    cpush(cons(xlenter("LAMBDA"),NIL));    /* (LAMBDA) */
X    rplacd(top(),cons(cdr(list),NIL));    /* (LAMBDA args) */
X    rplacd(cdr(top()),body);        /* (LAMBDA args body) */
X    settop(cons(top(),NIL));        /* ((LAMBDA args body)) */
X    define1(car(list),top(),cont);
X    drop(1);
X    }
X
X    /* compile procedure definitions */
X    else {
X
X    /* make sure it's a symbol */
X    if (!symbolp(list))
X        xlerror("expecting a symbol",list);
X
X    /* check for a procedure definition */
X    if (consp(body)
X        &&  consp(car(body))
X        &&  car(car(body)) == xlenter("LAMBDA")) {
X        fargs = car(cdr(car(body)));
X        body = cdr(cdr(car(body)));
X        cd_fundefinition(list,fargs,body);
X    }
X
X    /* compile the value expression or procedure body */
X    else
X        do_begin(body,C_NEXT);
X
X    /* define the variable value */
X    if (findcvariable(list,&off))
X        cd_evariable(OP_ESET,0,off);
X    else
X        cd_variable(OP_GSET,list);
X    do_literal(list,cont);
X    }
X}
X
X/* do_set - compile the (SET! ... ) expression */
XLOCAL do_set(form,cont)
X  LVAL form; int cont;
X{
X    if (atom(form))
X    xlerror("expecting symbol or ACCESS form",form);
X    else if (symbolp(car(form)))
X    do_setvar(form,cont);
X    else if (consp(car(form)))
X    do_setaccess(form,cont);
X    else
X    xlerror("expecting symbol or ACCESS form",form);
X}
X
X/* do_setvar - compile the (SET! var value) expression */
XLOCAL do_setvar(form,cont)
X  LVAL form; int cont;
X{
X    int lev,off;
X    LVAL sym;
X
X    /* get the variable name */
X    sym = car(form);
X
X    /* compile the value expression */
X    form = cdr(form);
X    if (atom(form))
X    xlerror("expecting value expression",form);
X    do_expr(car(form),C_NEXT);
X
X    /* set the variable value */
X    if (findvariable(sym,&lev,&off))
X    cd_evariable(OP_ESET,lev,off);
X    else
X    cd_variable(OP_GSET,sym);
X    do_continuation(cont);
X}
X
X/* do_quote - compile the (QUOTE ... ) expression */
XLOCAL do_quote(form,cont)
X  LVAL form; int cont;
X{
X    if (atom(form))
X    xlerror("expecting quoted expression",form);
X    do_literal(car(form),cont);
X}
X
X/* do_lambda - compile the (LAMBDA ... ) expression */
XLOCAL do_lambda(form,cont)
X  LVAL form; int cont;
X{
X    if (atom(form))
X    xlerror("expecting argument list",form);
X    cd_fundefinition(NIL,car(form),cdr(form));
X    do_continuation(cont);
X}
X
X/* cd_fundefinition - compile the function */
XLOCAL cd_fundefinition(fun,fargs,body)
X  LVAL fun,fargs,body;
X{
X    int oldcbase;
X
X    /* establish a new environment frame */
X    oldcbase = add_level();
X
X    /* compile the lambda list and the function body */
X    parse_lambda_list(fargs,body);
X    do_begin(body,C_RETURN);
X
X    /* build the code object */
X    cpush(make_code_object(fun));
X
X    /* restore the previous environment */
X    remove_level(oldcbase);
X
X    /* compile code to create a closure */
X    do_literal(pop(),C_NEXT);
X    putcbyte(OP_CLOSE);
X}
X
X/* parse_lambda_list - parse the formal argument list */
XLOCAL parse_lambda_list(fargs,body)
X  LVAL fargs,body;
X{
X    LVAL arg,restarg,new,last;
X    int frame,slotn;
X
X    /* setup the entry code */
X    putcbyte(OP_FRAME);
X    frame = putcbyte(0);
X
X    /* initialize the argument name list and slot number */
X    restarg = last = NIL;
X    slotn = 1;
X
X    /* handle each required argument */
X    while (consp(fargs) && (arg = car(fargs)) && !lambdakey(arg)) {
X
X    /* make sure the argument is a symbol */
X    if (!symbolp(arg))
X        xlerror("variable must be a symbol",arg);
X
X    /* add the argument name to the name list */
X    new = cons(arg,NIL);
X    if (last) rplacd(last,new);
X    else setelement(car(car(info)),0,new);
X    last = new;
X
X    /* generate an instruction to move the argument into the frame */
X    putcbyte(OP_MVARG);
X    putcbyte(slotn++);
X
X    /* move the formal argument list pointer ahead */
X    fargs = cdr(fargs);
X    }
X
X    /* check for the '#!optional' argument */
X    if (consp(fargs) && car(fargs) == lk_optional) {
X    fargs = cdr(fargs);
X
X    /* handle each optional argument */
X    while (consp(fargs) && (arg = car(fargs)) && !lambdakey(arg)) {
X
X        /* make sure the argument is a symbol */
X        if (!symbolp(arg))
X        xlerror("#!optional variable must be a symbol",arg);
X
X        /* add the argument name to the name list */
X        new = cons(arg,NIL);
X        if (last) rplacd(last,new);
X        else setelement(car(car(info)),0,new);
X        last = new;
X
X        /* move the argument into the frame */
X        putcbyte(OP_MVOARG);
X        putcbyte(slotn++);
X
X        /* move the formal argument list pointer ahead */
X        fargs = cdr(fargs);
X    }
X    }
X
X    /* check for the '#!rest' argument */
X    if (consp(fargs) && car(fargs) == lk_rest) {
X    fargs = cdr(fargs);
X
X    /* handle the rest argument */
X    if (consp(fargs) && (restarg = car(fargs)) && !lambdakey(restarg)) {
X
X        /* make sure the argument is a symbol */
X        if (!symbolp(restarg))
X        xlerror("#!rest variable must be a symbol",restarg);
X
X        /* add the argument name to the name list */
X        new = cons(restarg,NIL);
X        if (last) rplacd(last,new);
X        else setelement(car(car(info)),0,new);
X        last = new;
X
X        /* make the #!rest argument list */
X        putcbyte(OP_MVRARG);
X        putcbyte(slotn++);
X
X        /* move the formal argument list pointer ahead */
X        fargs = cdr(fargs);
X    }
X    else
X        xlerror("expecting the #!rest variable");
X    }
X
X    /* check for the a dotted tail */
X    if (restarg == NIL && symbolp(fargs)) {
X    restarg = fargs;
X
X    /* add the argument name to the name list */
X    new = cons(restarg,NIL);
X    if (last) rplacd(last,new);
X    else setelement(car(car(info)),0,new);
X    last = new;
X
X    /* make the #!rest argument list */
X    putcbyte(OP_MVRARG);
X    putcbyte(slotn++);
X    fargs = NIL;
X    }
X
X    /* check for the end of the argument list */
X    if (fargs != NIL)
X    xlerror("bad argument list tail",fargs);
X
X    /* make sure the user didn't supply too many arguments */
X    if (restarg == NIL)
X    putcbyte(OP_ALAST);
X
X    /* scan the body for internal definitions */
X    slotn += find_internal_definitions(body,last);
X
X    /* fixup the frame instruction */
X    cbuff[cbase+frame] = slotn;
X}
X
X/* find_internal_definitions - find internal definitions */
XLOCAL int find_internal_definitions(body,last)
X  LVAL body,last;
X{
X    LVAL define,sym,new;
X    int n=0;
X
X    /* look for all (define...) forms */
X    for (define = xlenter("DEFINE"); consp(body); body = cdr(body))
X    if (consp(car(body)) && car(car(body)) == define) {
X        sym = cdr(car(body)); /* the rest of the (define...) form */
X        if (consp(sym)) {     /* make sure there is a second subform */
X        sym = car(sym);   /* get the second subform */
X        while (consp(sym))/* check for a procedure definition */
X            sym = car(sym);
X        if (symbolp(sym)) {
X            new = cons(sym,NIL);
X            if (last) rplacd(last,new);
X            else setelement(car(car(info)),0,new);
X            last = new;
X            ++n;
X        }
X        }
X    }
X    return (n);
X}
X
X/* do_delay - compile the (DELAY ... ) expression */
XLOCAL do_delay(form,cont)
X  LVAL form; int cont;
X{
X    int oldcbase;
X
X    /* check argument list */
X    if (atom(form))
X    xlerror("expecting delay expression",form);
X
X    /* establish a new environment frame */
X    oldcbase = add_level();
X
X    /* setup the entry code */
X    putcbyte(OP_FRAME);
X    putcbyte(1);
X
X    /* compile the expression */
X    do_expr(car(form),C_RETURN);
X
X    /* build the code object */
X    cpush(make_code_object(NIL));
X
X    /* restore the previous environment */
X    remove_level(oldcbase);
X
X    /* compile code to create a closure */
X    do_literal(pop(),C_NEXT);
X    putcbyte(OP_DELAY);
X    do_continuation(cont);
X}
X
X/* do_let - compile the (LET ... ) expression */
XLOCAL do_let(form,cont)
X  LVAL form; int cont;
X{
X    /* handle named let */
X    if (consp(form) && symbolp(car(form)))
X    do_named_let(form,cont);
X
X    /* handle unnamed let */
X    else
X        cd_let(NIL,form,cont);
X}
X
X/* do_named_let - compile the (LET name ... ) expression */
XLOCAL do_named_let(form,cont)
X  LVAL form; int cont;
X{
X    int oldcbase,nxt;
X
X    /* save a continuation */
X    if (cont != C_RETURN) {
X    putcbyte(OP_SAVE);
X    nxt = putcword(0);
X    }
X
X    /* establish a new environment frame */
X    oldcbase = add_level();
X    setelement(car(car(info)),0,cons(car(form),NIL));
X
X    /* setup the entry code */
X    putcbyte(OP_FRAME);
X    putcbyte(2);
X
X    /* compile the let expression */
X    cd_let(car(form),cdr(form),C_RETURN);
X
X    /* build the code object */
X    cpush(make_code_object(NIL));
X
X    /* restore the previous environment */
X    remove_level(oldcbase);
X
X    /* compile code to create a closure */
X    do_literal(pop(),C_NEXT);
X    putcbyte(OP_CLOSE);
X
X    /* apply the function */
X    putcbyte(OP_CALL);
X    putcbyte(1);
X
X    /* target for the continuation */
X    if (cont != C_RETURN)
X    fixup(nxt);
X}
X
X/* cd_let - code a let expression */
XLOCAL cd_let(name,form,cont)
X  LVAL name,form; int cont;
X{
X    int oldcbase,nxt,lev,off,n;
X
X    /* make sure there is a binding list */
X    if (atom(form) || !listp(car(form)))
X    xlerror("expecting binding list",form);
X
X    /* save a continuation */
X    if (cont != C_RETURN) {
X    putcbyte(OP_SAVE);
X    nxt = putcword(0);
X    }
X
X    /* push the initialization expressions */
X    n = push_init_expressions(car(form));
X
X    /* establish a new environment frame */
X    oldcbase = add_level();
X
X    /* compile the binding list */
X    parse_let_variables(car(form),cdr(form));
X
X    /* compile the body of the let/letrec */
X    do_begin(cdr(form),C_RETURN);
X
X    /* build the code object */
X    cpush(make_code_object(NIL));
X
X    /* restore the previous environment */
X    remove_level(oldcbase);
X
X    /* compile code to create a closure */
X    do_literal(pop(),C_NEXT);
X    putcbyte(OP_CLOSE);
X
X    /* store the procedure */
X    if (name && findvariable(name,&lev,&off))
X    cd_evariable(OP_ESET,lev,off);
X
X    /* apply the function */
X    putcbyte(OP_CALL);
X    putcbyte(n);
X
X    /* target for the continuation */
X    if (cont != C_RETURN)
X    fixup(nxt);
X}
X
X/* do_letrec - compile the (LETREC ... ) expression */
XLOCAL do_letrec(form,cont)
X  LVAL form; int cont;
X{
X    int oldcbase,nxt,n;
X
X    /* make sure there is a binding list */
X    if (atom(form) || !listp(car(form)))
X    xlerror("expecting binding list",form);
X
X    /* save a continuation */
X    if (cont != C_RETURN) {
X    putcbyte(OP_SAVE);
X    nxt = putcword(0);
X    }
X
X    /* push the initialization expressions */
X    n = push_dummy_values(car(form));
X
X    /* establish a new environment frame */
X    oldcbase = add_level();
X
X    /* compile the binding list */
X    parse_let_variables(car(form),cdr(form));
X
X    /* compile instructions to set the bound variables */
X    set_bound_variables(car(form));
X
X    /* compile the body of the let/letrec */
X    do_begin(cdr(form),C_RETURN);
X
X    /* build the code object */
X    cpush(make_code_object(NIL));
X
X    /* restore the previous environment */
X    remove_level(oldcbase);
X
X    /* compile code to create a closure */
X    do_literal(pop(),C_NEXT);
X    putcbyte(OP_CLOSE);
X
X    /* apply the function */
X    putcbyte(OP_CALL);
X    putcbyte(n);
X
X    /* target for the continuation */
X    if (cont != C_RETURN)
X    fixup(nxt);
X}
X
X/* do_letstar - compile the (LET* ... ) expression */
XLOCAL do_letstar(form,cont)
X  LVAL form; int cont;
X{
X    int nxt;
X
X    /* make sure there is a binding list */
X    if (atom(form) || !listp(car(form)))
X    xlerror("expecting binding list",form);
X
X    /* handle the case where there are bindings */
X    if (consp(car(form))) {
X
X    /* save a continuation */
X    if (cont != C_RETURN) {
X        putcbyte(OP_SAVE);
X        nxt = putcword(0);
X    }
X
X    /* build the nested lambda expressions */
X    letstar1(car(form),cdr(form));
X
X    /* target for the continuation */
X    if (cont != C_RETURN)
X        fixup(nxt);
X    }
X
X    /* handle the case where there are no bindings */
X    else
X    do_begin(cdr(form),cont);
X}
X
X/* letstar1 - helper routine for let* */
XLOCAL letstar1(blist,body)
X  LVAL blist,body;
X{
X    int oldcbase,n;
X
X    /* push the next initialization expressions */
X    cpush(cons(car(blist),NIL));
X    n = push_init_expressions(top());
X
X    /* establish a new environment frame */
X    oldcbase = add_level();
X
X    /* handle the case where there are more bindings */
X    if (consp(cdr(blist))) {
X    parse_let_variables(top(),NIL);
X    letstar1(cdr(blist),body);
X    }
X
X    /* handle the last binding */
X    else {
X    parse_let_variables(top(),body);
X    do_begin(body,C_RETURN);
X    }
X
X    /* build the code object */
X    settop(make_code_object(NIL));
X
X    /* restore the previous environment */
X    remove_level(oldcbase);
X
X    /* compile code to create a closure */
X    do_literal(pop(),C_NEXT);
X    putcbyte(OP_CLOSE);
X
X    /* apply the function */
X    putcbyte(OP_CALL);
X    putcbyte(n);
X}
X
X/* push_dummy_values - push dummy values for a 'letrec' expression */
XLOCAL int push_dummy_values(blist)
X  LVAL blist;
X{
X    int n=0;
X    if (consp(blist)) {
X    putcbyte(OP_NIL);
X    for (; consp(blist); blist = cdr(blist), ++n)
X        putcbyte(OP_PUSH);
X    }
X    return (n);
X}
X
X/* push_init_expressions - push init expressions for a 'let' expression */
XLOCAL int push_init_expressions(blist)
X  LVAL blist;
X{
X    int n;
X    if (consp(blist)) {
X    n = push_init_expressions(cdr(blist));
X    if (consp(car(blist)) && consp(cdr(car(blist))))
X        do_expr(car(cdr(car(blist))),C_NEXT);
X    else
X        putcbyte(OP_NIL);
X    putcbyte(OP_PUSH);
X    return (n+1);
X    }
X    return (0);
X}
X
X/* parse_let_variables - parse the binding list */
XLOCAL parse_let_variables(blist,body)
X  LVAL blist,body;
X{
X    LVAL arg,new,last;
X    int frame,slotn;
X
X    /* setup the entry code */
X    putcbyte(OP_FRAME);
X    frame = putcbyte(0);
X
X    /* initialize the argument name list and slot number */
X    last = NIL;
X    slotn = 1;
X
X    /* handle each required argument */
X    while (consp(blist) && (arg = car(blist))) {
X
X    /* make sure the argument is a symbol */
X    if (symbolp(arg))
X        new = cons(arg,NIL);
X    else if (consp(arg) && symbolp(car(arg)))
X        new = cons(car(arg),NIL);
X    else
X        xlerror("invalid binding",arg);
X
X    /* add the argument name to the name list */
X    if (last) rplacd(last,new);
X    else setelement(car(car(info)),0,new);
X    last = new;
X
X    /* generate an instruction to move the argument into the frame */
X    putcbyte(OP_MVARG);
X    putcbyte(slotn++);
X
X    /* move the formal argument list pointer ahead */
X    blist = cdr(blist);
X    }
X    putcbyte(OP_ALAST);
X
X    /* scan the body for internal definitions */
X    slotn += find_internal_definitions(body,last);
X
X    /* fixup the frame instruction */
X    cbuff[cbase+frame] = slotn;
X}
X
X/* set_bound_variables - set bound variables in a 'letrec' expression */
XLOCAL set_bound_variables(blist)
X  LVAL blist;
X{
X    int lev,off;
X    for (; consp(blist); blist = cdr(blist)) {
X    if (consp(car(blist)) && consp(cdr(car(blist)))) {
X        do_expr(car(cdr(car(blist))),C_NEXT);
X        if (findvariable(car(car(blist)),&lev,&off))
X        cd_evariable(OP_ESET,lev,off);
X        else
X        xlerror("compiler error -- can't find",car(car(blist)));
X    }
X    }
X}
X
X/* make_code_object - build a code object */
XLOCAL LVAL make_code_object(fun)
X  LVAL fun;
X{
X    unsigned char *cp;
X    LVAL code,p;
X    int i;
X
X    /* create a code object */
X    code = newcode(FIRSTLIT + length(car(cdr(info)))); cpush(code);
X    setbcode(code,newstring(cptr - cbase));
X    setcname(code,fun);                        /* function name */
X    setvnames(code,getelement(car(car(info)),0));/* lambda list variables */
X
X    /* copy the literals into the code object */
X    for (i = FIRSTLIT, p = car(cdr(info)); consp(p); p = cdr(p), ++i)
X    setelement(code,i,car(p));
X
X    /* copy the byte codes */
X    for (i = cbase, cp = getstring(getbcode(code)); i < cptr; )
X    *cp++ = cbuff[i++];
X
X    /* return the new code object */
X    return (pop());
X}
X
X/* do_cond - compile the (COND ... ) expression */
XLOCAL do_cond(form,cont)
X  LVAL form; int cont;
X{
X    int nxt,end;
X    if (consp(form)) {
X    for (end = 0; consp(form); form = cdr(form)) {
X        if (atom(car(form)))
X        xlerror("expecting a cond clause",form);
X        do_expr(car(car(form)),C_NEXT);
X        putcbyte(OP_BRF);
X        nxt = putcword(0);
X        if (cdr(car(form)))
X        do_begin(cdr(car(form)),cont);
X        else
X        do_continuation(cont);
X        if (cont == C_NEXT) {
X        putcbyte(OP_BR);
X        end = putcword(end);
X        }
X        fixup(nxt);
X    }
X    fixup(end);
X    }
X    else
X    putcbyte(OP_NIL);
X    do_continuation(cont);
X}
X
X/* do_and - compile the (AND ... ) expression */
XLOCAL do_and(form,cont)
X  LVAL form; int cont;
X{
X    int end;
X    if (consp(form)) {
X    for (end = 0; consp(form); form = cdr(form)) {
X        if (cdr(form)) {
X        do_expr(car(form),C_NEXT);
X        putcbyte(OP_BRF);
X        end = putcword(end);
X        }
X        else
X        do_expr(car(form),cont);
X    }
X    fixup(end);
X    }
X    else
X    putcbyte(OP_T);
X    do_continuation(cont);
X}
X
X/* do_or - compile the (OR ... ) expression */
XLOCAL do_or(form,cont)
X  LVAL form; int cont;
X{
X    int end;
X    if (consp(form)) {
X    for (end = 0; consp(form); form = cdr(form)) {
X        if (cdr(form)) {
X        do_expr(car(form),C_NEXT);
X        putcbyte(OP_BRT);
X        end = putcword(end);
X        }
X        else
X        do_expr(car(form),cont);
X    }
X    fixup(end);
X    }
X    else
X    putcbyte(OP_NIL);
X    do_continuation(cont);
X}
X
X/* do_if - compile the (IF ... ) expression */
XLOCAL do_if(form,cont)
X  LVAL form; int cont;
X{
X    int nxt,end;
X
X    /* compile the test expression */
X    if (atom(form))
X    xlerror("expecting test expression",form);
X    do_expr(car(form),C_NEXT);
X
X    /* skip around the 'then' clause if the expression is false */
X    putcbyte(OP_BRF);
X    nxt = putcword(0);
X
X    /* skip to the 'then' clause */
X    form = cdr(form);
X    if (atom(form))
X    xlerror("expecting then clause",form);
X
X    /* compile the 'then' and 'else' clauses */
X    if (consp(cdr(form))) {
X    if (cont == C_NEXT) {
X        do_expr(car(form),C_NEXT);
X        putcbyte(OP_BR);
X        end = putcword(0);
X    }
X    else {
X        do_expr(car(form),cont);
X        end = -1;
X    }
X    fixup(nxt);
X    do_expr(car(cdr(form)),cont);
X    nxt = end;
X    }
X
X    /* compile just a 'then' clause */
X    else
X    do_expr(car(form),cont);
X
X    /* handle the end of the statement */
X    if (nxt >= 0) {
X    fixup(nxt);
X    do_continuation(cont);
X    }
X}
X
X/* do_begin - compile the (BEGIN ... ) expression */
XLOCAL do_begin(form,cont)
X  LVAL form; int cont;
X{
X    if (consp(form))
X    for (; consp(form); form = cdr(form))
X        if (consp(cdr(form)))
X        do_expr(car(form),C_NEXT);
X        else
X        do_expr(car(form),cont);
X    else {
X    putcbyte(OP_NIL);
X    do_continuation(cont);
X    }
X}
X
X/* do_while - compile the (WHILE ... ) expression */
XLOCAL do_while(form,cont)
X  LVAL form; int cont;
X{
X    int loop,nxt;
X
X    /* make sure there is a test expression */
X    if (atom(form))
X    xlerror("expecting test expression",form);
X
X    /* skip around the 'body' to the test expression */
X    putcbyte(OP_BR);
X    nxt = putcword(0);
X
X    /* compile the loop body */
X    loop = cptr - cbase;
X    do_begin(cdr(form),C_NEXT);
X
X    /* label for the first iteration */
X    fixup(nxt);
X
X    /* compile the test expression */
X    nxt = cptr - cbase;
X    do_expr(car(form),C_NEXT);
X
X    /* skip around the 'body' if the expression is false */
X    putcbyte(OP_BRT);
X    putcword(loop);
X
X    /* compile the continuation */
X    do_continuation(cont);
X}
X
X/* do_access - compile the (ACCESS var env) expression */
XLOCAL do_access(form,cont)
X  LVAL form; int cont;
X{
X    LVAL sym;
X
X    /* get the variable name */
X    if (atom(form) || !symbolp(car(form)))
X    xlerror("expecting symbol",form);
X    sym = car(form);
X
X    /* compile the environment expression */
X    form = cdr(form);
X    if (atom(form))
X    xlerror("expecting environment expression",form);
X    do_expr(car(form),C_NEXT);
X
X    /* get the variable value */
X    cd_variable(OP_AREF,sym);
X    do_continuation(cont);
X}
X
X/* do_setaccess - compile the (SET! (ACCESS var env) value) expression */
XLOCAL do_setaccess(form,cont)
X  LVAL form; int cont;
X{
X    LVAL aform,sym;
X
X    /* make sure this is an access form */
X    aform = car(form);
X    if (atom(aform) || car(aform) != xlenter("ACCESS"))
X    xlerror("expecting an ACCESS form",aform);
X
X    /* get the variable name */
X    aform = cdr(aform);
X    if (atom(aform) || !symbolp(car(aform)))
X    xlerror("expecting symbol",aform);
X    sym = car(aform);
X
X    /* compile the environment expression */
X    aform = cdr(aform);
X    if (atom(aform))
X    xlerror("expecting environment expression",aform);
X    do_expr(car(aform),C_NEXT);
X    putcbyte(OP_PUSH);
X
X    /* compile the value expression */
X    form = cdr(form);
X    if (atom(form))
X    xlerror("expecting value expression",form);
X    do_expr(car(form),C_NEXT);
X
X    /* set the variable value */
X    cd_variable(OP_ASET,sym);
X    do_continuation(cont);
X}
X
X/* do_call - compile a function call */
XLOCAL do_call(form,cont)
X  LVAL form; int cont;
X{
X    int nxt,n;
X
X    /* save a continuation */
X    if (cont != C_RETURN) {
X    putcbyte(OP_SAVE);
X    nxt = putcword(0);
X    }
X
X    /* compile each argument expression */
X    n = push_args(cdr(form));
X
X    /* compile the function itself */
X    do_expr(car(form),C_NEXT);
X
X    /* apply the function */
X    putcbyte(OP_CALL);
X    putcbyte(n);
X
X    /* target for the continuation */
X    if (cont != C_RETURN)
X    fixup(nxt);
X}
X
X/* push_args - compile the arguments for a function call */
XLOCAL int push_args(form)
X  LVAL form;
X{
X    int n;
X    if (consp(form)) {
X    n = push_args(cdr(form));
X    do_expr(car(form),C_NEXT);
X    putcbyte(OP_PUSH);
X    return (n+1);
X    }
X    return (0);
X}
X
X/* do_nary - compile nary operator expressions */
XLOCAL do_nary(op,n,form,cont)
X  int op,n; LVAL form; int cont;
X{
X    if (n < 0 && (n = (-n)) != length(cdr(form)))
X    do_call(form,cont);
X    else {
X    push_nargs(cdr(form),n);
X    putcbyte(op);
X    do_continuation(cont);
X    }
X}
X
X/* push_nargs - compile the arguments for an inline function call */
XLOCAL int push_nargs(form,n)
X  LVAL form; int n;
X{
X    if (consp(form)) {
X    if (n == 0)
X        xlerror("too many arguments",form);
X    if (push_nargs(cdr(form),n-1))
X        putcbyte(OP_PUSH);
X    do_expr(car(form),C_NEXT);
X    return (TRUE);
X    }
X    if (n)
X    xlerror("too few arguments",form);
X    return (FALSE);
X}
X
X/* do_literal - compile a literal */
XLOCAL do_literal(lit,cont)
X  LVAL lit; int cont;
X{
X    cd_literal(lit);
X    do_continuation(cont);
X}
X
X/* do_identifier - compile an identifier */
XLOCAL do_identifier(sym,cont)
X  LVAL sym; int cont;
X{
X    int lev,off;
X    if (sym == true)
X    putcbyte(OP_T);
X    else if (findvariable(sym,&lev,&off))
X    cd_evariable(OP_EREF,lev,off);
X    else
X    cd_variable(OP_GREF,sym);
X    do_continuation(cont);
X}
X
X/* do_continuation - compile a continuation */
XLOCAL do_continuation(cont)
X  int cont;
X{
X    switch (cont) {
X    case C_RETURN:
X    putcbyte(OP_RETURN);
X    break;
X    case C_NEXT:
X    break;
X    }
X}
X
X/* add_level - add a nesting level */
XLOCAL int add_level()
X{
X    int oldcbase;
X
X    /* establish a new environment frame */
X    rplaca(info,newframe(car(info),1));
X    rplacd(info,cons(NIL,cdr(info)));
X
X    /* setup the base of the code for this function */
X    oldcbase = cbase;
X    cbase = cptr;
X
X    /* return the old code base */
X    return (oldcbase);
X}
X
X/* remove_level - remove a nesting level */
XLOCAL remove_level(oldcbase)
X  int oldcbase;
X{
X    /* restore the previous environment */
X    rplaca(info,cdr(car(info)));
X    rplacd(info,cdr(cdr(info)));
X
X    /* restore the base and code pointer */
X    cptr = cbase;
X    cbase = oldcbase;
X}
X
X/* findvariable - find an environment variable */
XLOCAL int findvariable(sym,plev,poff)
X  LVAL sym; int *plev,*poff;
X{
X    int lev,off;
X    LVAL e,a;
X    for (e = car(info), lev = 0; envp(e); e = cdr(e), ++lev)
X    for (a = getelement(car(e),0), off = 1; consp(a); a = cdr(a), ++off)
X        if (sym == car(a)) {
X        *plev = lev;
X        *poff = off;
X        return (TRUE);
X        }
X    return (FALSE);
X}
X
X/* findcvariable - find an environment variable in the current frame */
XLOCAL int findcvariable(sym,poff)
X  LVAL sym; int *poff;
X{
X    int off;
X    LVAL a;
X    a = getelement(car(car(info)),0);
X    for (off = 1; consp(a); a = cdr(a), ++off)
X    if (sym == car(a)) {
X        *poff = off;
X        return (TRUE);
X    }
X    return (FALSE);
X}
X
X/* findliteral - find a literal in the literal frame */
XLOCAL int findliteral(lit)
X  LVAL lit;
X{
X    int o = FIRSTLIT;
X    LVAL t,p;
X    if (t = car(cdr(info))) {
X    for (p = NIL; consp(t); p = t, t = cdr(t), ++o)
X        if (equal(lit,car(t)))
X        return (o);
X    rplacd(p,cons(lit,NIL));
X    }
X    else
X    rplaca(cdr(info),cons(lit,NIL));
X    return (o);
X}
X
X/* cd_variable - compile a variable reference */
XLOCAL cd_variable(op,sym)
X  int op; LVAL sym;
X{
X    putcbyte(op);
X    putcbyte(findliteral(sym));
X}
X
X/* cd_evariable - compile an environment variable reference */
XLOCAL cd_evariable(op,lev,off)
X  int op,lev,off;
X{
X    putcbyte(op);
X    putcbyte(lev);
X    putcbyte(off);
X}
X
X/* cd_literal - compile a literal reference */
XLOCAL cd_literal(lit)
X  LVAL lit;
X{
X    if (lit == NIL)
X    putcbyte(OP_NIL);
X    else if (lit == true)
X    putcbyte(OP_T);
X    else {
X    putcbyte(OP_LIT);
X    putcbyte(findliteral(lit));
X    }
X}
X
X/* putcbyte - put a code byte into data space */
XLOCAL int putcbyte(b)
X  int b;
X{
X    int adr;
X    if (cptr >= CMAX)
X    xlabort("insufficient code space");
X    adr = (cptr - cbase);
X    cbuff[cptr++] = b;
X    return (adr);
X}
X
X/* putcword - put a code word into data space */
XLOCAL int putcword(w)
X  int w;
X{
X    int adr;
X    adr = putcbyte(w >> 8);
X    putcbyte(w);
X    return (adr);
X}
X
X/* fixup - fixup a reference chain */
XLOCAL fixup(chn)
X  int chn;
X{
X    int val,hval,nxt;
X
X    /* store the value into each location in the chain */
X    val = cptr - cbase; hval = val >> 8;
X    for (; chn; chn = nxt) {
X    nxt = (cbuff[cbase+chn] << 8) | (cbuff[cbase+chn+1]);
X    cbuff[cbase+chn] = hval;
X    cbuff[cbase+chn+1] = val;
X    }
X}
X
X/* length - find the length of a list */
Xint length(list)
X  LVAL list;
X{
X    int len;
X    for (len = 0; consp(list); list = cdr(list))
X    ++len;
X    return (len);
X}
X
X/* instruction output formats */
X#define FMT_NONE    0
X#define FMT_BYTE    1
X#define FMT_LOFF    2
X#define FMT_WORD    3
X#define FMT_EOFF    4
X
Xtypedef struct { int ot_code; char *ot_name; int ot_fmt; } OTDEF;
XOTDEF otab[] = {
X{    OP_BRT,        "BRT",        FMT_WORD    },
X{    OP_BRF,        "BRF",        FMT_WORD    },
X{    OP_BR,        "BR",        FMT_WORD    },
X{    OP_LIT,        "LIT",        FMT_LOFF    },
X{    OP_GREF,    "GREF",        FMT_LOFF    },
X{    OP_GSET,    "GSET",        FMT_LOFF    },
X{    OP_EREF,    "EREF",        FMT_EOFF    },
X{    OP_ESET,    "ESET",        FMT_EOFF    },
X{    OP_SAVE,    "SAVE",        FMT_WORD    },
X{    OP_CALL,    "CALL",        FMT_BYTE    },
X{    OP_RETURN,    "RETURN",    FMT_NONE    },
X{    OP_T,        "T",        FMT_NONE    },
X{    OP_NIL,        "NIL",        FMT_NONE    },
X{    OP_PUSH,    "PUSH",        FMT_NONE    },
X{    OP_CLOSE,    "CLOSE",    FMT_NONE    },
X{    OP_DELAY,    "DELAY",    FMT_NONE    },
X
X{    OP_FRAME,    "FRAME",    FMT_BYTE    },
X{    OP_MVARG,    "MVARG",    FMT_BYTE    },
X{    OP_MVOARG,    "MVOARG",    FMT_BYTE    },
X{    OP_MVRARG,    "MVRARG",    FMT_BYTE    },
X{    OP_ADROP,    "ADROP",    FMT_NONE    },
X{    OP_ALAST,    "ALAST",    FMT_NONE    },
X
X{    OP_AREF,    "AREF",        FMT_LOFF    },
X{    OP_ASET,    "ASET",        FMT_LOFF    },
X
X{0,0,0}
X};
X
X/* decode_procedure - decode the instructions in a code object */
Xdecode_procedure(fptr,fun)
X  LVAL fptr,fun;
X{
X    int len,lc,n;
X    LVAL code,env;
X    code = getcode(fun);
X    env = getenv(fun);
X    len = getslength(getbcode(code));
X    for (lc = 0; lc < len; lc += n)
X    n = decode_instruction(fptr,code,lc,env);
X}
X
X/* decode_instruction - decode a single bytecode instruction */
Xint decode_instruction(fptr,code,lc,env)
X  LVAL fptr,code; int lc; LVAL env;
X{
X    unsigned char *cp;
X    char buf[100];
X    OTDEF *op;
X    NTDEF *np;
X    int i,n=1;
X    LVAL tmp;
X
X    /* get a pointer to the bytecodes for this instruction */
X    cp = getstring(getbcode(code)) + lc;
X
X    /* show the address and opcode */
X    if (tmp = getcname(code))
X    sprintf(buf,"%s:%04x %02x ",getstring(getpname(tmp)),lc,*cp);
X    else {
X    sprintf(buf,AFMT,code); xlputstr(fptr,buf);
X        sprintf(buf,":%04x %02x ",lc,*cp);
X    }
X    xlputstr(fptr,buf);
X
X    /* display the operands */
X    for (op = otab; op->ot_name; ++op)
X    if (*cp == op->ot_code) {
X        switch (op->ot_fmt) {
X        case FMT_NONE:
X        sprintf(buf,"      %s\n",op->ot_name);
X        xlputstr(fptr,buf);
X        break;
X        case FMT_BYTE:
X        sprintf(buf,"%02x    %s %02x\n",cp[1],op->ot_name,cp[1]);
X        xlputstr(fptr,buf);
X        n += 1;
X        break;
X        case FMT_LOFF:
X        sprintf(buf,"%02x    %s %02x ; ",cp[1],op->ot_name,cp[1]);
X        xlputstr(fptr,buf);
X        xlprin1(getelement(code,cp[1]),fptr);
X        xlterpri(fptr);
X        n += 1;
X        break;
X        case FMT_WORD:
X        sprintf(buf,"%02x %02x %s %02x%02x\n",cp[1],cp[2],
X            op->ot_name,cp[1],cp[2]);
X        xlputstr(fptr,buf);
X        n += 2;
X        break;
X        case FMT_EOFF:
X        if ((i = cp[1]) == 0)
X            tmp = getvnames(code);
X        else {
X            for (tmp = env; i > 1; --i) tmp = cdr(tmp);
X            tmp = getelement(car(tmp),0);
X        }
X        for (i = cp[2]; i > 1; --i) tmp = cdr(tmp);
X        sprintf(buf,"%02x %02x %s %02x %02x ; ",cp[1],cp[2],
X            op->ot_name,cp[1],cp[2]);
X        xlputstr(fptr,buf);
X        xlprin1(car(tmp),fptr);
X        xlterpri(fptr);
X        n += 2;
X        break;
X        }
X        return (n);
X    }
X
X    /* check for an integrable function */
X    for (np = ntab; np->nt_name; ++np)
X    if (*cp == np->nt_code) {
X        sprintf(buf,"      %s\n",np->nt_name);
X        xlputstr(fptr,buf);
X        return (n);
X    }
X
X    /* unknown opcode */
X    sprintf(buf,"      <UNKNOWN>\n");
X    xlputstr(fptr,buf);
X    return (n);
X}
END_OF_FILE
if test 33402 -ne `wc -c <'Src/xscom.c'`; then
    echo shar: \"'Src/xscom.c'\" unpacked with wrong size!
fi
# end of 'Src/xscom.c'
fi
echo shar: End of archive 5 \(of 7\).
cp /dev/null ark5isdone
MISSING=""
for I in 1 2 3 4 5 6 7 ; do
    if test ! -f ark${I}isdone ; then
    MISSING="${MISSING} ${I}"
    fi
done
if test "${MISSING}" = "" ; then
    echo You have unpacked all 7 archives.
    rm -f ark[1-9]isdone
else
    echo You still need to unpack the following archives:
    echo "        " ${MISSING}
fi
##  End of shell archive.
exit 0
--
Mail submissions (sources or binaries) to <[e-mail]>.
Mail comments to the moderator at <[e-mail]>.
Post requests for sources, and general discussion to comp.sys.amiga.